home *** CD-ROM | disk | FTP | other *** search
/ Computer Select (Limited Edition) / Computer Select.iso / dobbs / v16n08 / lisplike.asc < prev    next >
Encoding:
Text File  |  1991-07-23  |  43.8 KB  |  1,494 lines
  1. _A LISP-STYLE LIBRARY FOR C_
  2. by Daniel N. Ozick
  3.  
  4. [LISTING ONE]
  5.  
  6. /* file LISP.H of 6-Feb-91 / Copyright (C) 1990 by Daniel N. Ozick */
  7. /* Lisp-Style Library for C (Main Header File) */
  8.  
  9. /* Constants */
  10. /* Array Sizes */
  11. #define MAXSTRING 128           /* size of standard character array  */
  12. #define MAXLINE 256             /* size of text line character array */
  13. #define HASH_TABLE_SZ 211       /* size of HASH_TABLE -- should be prime */
  14.  
  15. /* Characters */
  16. #define EOS '\0'                /* end of string */
  17. #define TAB '\t'
  18. #define NEWLINE '\n'
  19. #define FORMFEED '\f'
  20. #define SPACE 32
  21. #define BELL 7
  22. #define BACKSPACE 8
  23. #define RETURN 13
  24. #define LINEFEED 10
  25. #define ESCAPE 27
  26. #define DOT '.'
  27. #define PERIOD '.'
  28. #define DOS_EOF 26
  29. #define BACKSLASH '\\'
  30. #define SINGLE_QUOTE '\''
  31. #define DOUBLE_QUOTE '\"'
  32. #define LEFT_PAREN '('
  33. #define RIGHT_PAREN ')'
  34. #define LINE_SPLICE (-2)
  35.  
  36. /* Strings */
  37. #define NULLSTR ""
  38. #define NEWLINESTR "\n"
  39. /** Types **/
  40. /* Boolean -- standard truth values */
  41. typedef enum
  42.  {
  43.   FALSE,
  44.   TRUE
  45.  } Boolean;
  46. #if 0
  47. /* Note: The following 'enum' version of Object_Type uses an 'int' (16 bits)
  48.    of storage under Microsoft C 6.0! */
  49. /* Object_Type -- values for first component of 'Object' (self-id tag) */
  50. typedef enum
  51.  {
  52.   /* General Types */
  53.   UNDEFINED,
  54.   SYMBOL,
  55.   STRING,
  56.   INTEGER,
  57.   FUNCTION,
  58.   PAIR,
  59.   VECTOR,
  60.   /* Built-in C Structures */
  61.   TOKEN,
  62.  } Object_Type;
  63. #endif
  64. /* Note: The following version of Object_Type is guaranteed to use only one 
  65. 'char' of storage. (Contrast with 'enum' version, above.) */
  66. /* Object_Type -- values for first component of 'Object' (self-id tag) */
  67. typedef char Object_Type;
  68. /* General Types */
  69. #define UNDEFINED       0
  70. #define SYMBOL          1
  71. #define STRING          2
  72. #define INTEGER         3
  73. #define FUNCTION        4
  74. #define PAIR            5
  75. #define VECTOR          6
  76. /* Built-in C Structures */
  77. #define TOKEN           7
  78. /* Pointer -- 'Generic *' : what's pointed to is unknown at compile time */
  79. typedef void *Pointer;
  80. /* Object -- pointer to self-identified object (starts with Object_Type) */
  81. typedef Object_Type *Object;
  82. /* Function -- pointer to function of ? arguments returning Object */
  83. typedef Object (*Function)(Object, ...); 
  84. /* Function_0 -- pointer to function of 0 arguments returning Object */
  85. typedef Object (*Function_0)(void); 
  86. /* Function_1 -- pointer to function of 1 Object returning Object */
  87. typedef Object (*Function_1)(Object); 
  88. /* Symbol_Entry -- the attributes of a symbol (entered into Symbol_Table) */
  89. typedef struct
  90.  {
  91.   char *print_name;     /* printed representation and lookup key    */
  92.   Object value;         /* value of global variable named by symbol */
  93.  } Symbol_Entry;
  94. /* Pair -- a Lisp 'cons' cell for creating linked lists */
  95. typedef struct
  96.  {
  97.   Object car;           /* any Object */
  98.   Object cdr;           /* PAIR Object or NULL (usually) */
  99.  } Pair;
  100. /* Token -- structure Object stores token type and lexeme string */
  101. typedef struct
  102.  {
  103.   Object type;          /* SYMBOL */
  104.   char *lexeme;         /* string as it appeared in external file */
  105.  } Token;
  106. /* Hash_Table -- an array of hash-bucket lists used for symbol tables */
  107. typedef Object Hash_Table [HASH_TABLE_SZ];
  108. /** Macros **/
  109. /* Standard Input and Output */
  110. #define ungetchar(c)            ungetc (c, stdin)
  111. #define peekchar()              ungetc (getchar(), stdin)
  112. /** Object Components **/
  113. /* SOT -- size of 'Object_Type' (bytes used by type tag) */
  114. #define SOT sizeof (Object_Type)
  115. /* type -- return the object's self-identification (Object_Type) */
  116. #define type(object)            *((Object_Type *) object)
  117. /* symbol -- return the address of symbol's name and value (Symbol_Entry) */
  118. #define symbol(object)          ((Symbol_Entry *) (object + SOT))
  119. /* symbol_value -- return the value assigned to a symbol */
  120. #define symbol_value(object)    (symbol(object)->value)
  121. /* string -- return the address of (the first char of) standard C string */
  122. #define string(object)          ((char *) (object + SOT))
  123. /* integer -- return an 'int' */
  124. #define integer(object)         *((int *) (object + SOT))
  125. /* function -- return the address of a function that returns Object */
  126. #define function(object)        *((Function *) (object + SOT))
  127. /* pair -- return the address of a Lisp-style CONS cell */
  128. #define pair(object)            ((Pair *) (object + SOT))
  129. /* first -- return first element of a list (Lisp CAR) */
  130. #define first(object)           (pair(object)->car)
  131. /* but_first -- return list less its first element (Lisp CDR) */
  132. #define but_first(object)       (pair(object)->cdr)
  133. /* vector -- return the base address of a 1-dimensional array of Object */
  134. #define vector(object)          ((Object *) (object + SOT + sizeof (int)))
  135. /* vector_length -- return length of a VECTOR Object (also an lvalue) */
  136. #define vector_length(object)   *((int *) (object + SOT))
  137. /* token -- return the address of a Token structure */
  138. #define token(object)           ((Token *) (object + SOT))
  139. /* Type Predicates */
  140. #define is_null(object)         (object == NULL)
  141. #define is_symbol(object)       (type(object) == SYMBOL)
  142. #define is_pair(object)         (type(object) == PAIR)
  143. #define is_atom(object)         (is_null(object) || (type(object) != PAIR))
  144. #define is_list(object)         (is_null(object) || is_pair(object))
  145. #define is_vector(object)       (type(object) == VECTOR)
  146. #define is_string(object)       (type(object) == STRING)
  147. #define is_integer(object)      (type(object) == INTEGER)
  148. #define is_function(object)     (type(object) == FUNCTION)
  149. #define is_token(object)        (type(object) == TOKEN)
  150. /* declare_symbol -- declare extern var with same name as interned sym */
  151. #define declare_symbol(name,type)       extern Object name;
  152. /* List-Based Stacks */
  153. /* push -- push an object on to a (list-based) stack */
  154. #define push(location,object)   \
  155.   location = first_put (object, location)
  156. /* pop -- pop an object off of a (list-based) stack, NULL if stack empty */
  157. #define pop(location)           \
  158.   ( (location != NULL) ?        \
  159.     pop_f (&location) : NULL )
  160. /* Function Prototypes */
  161. void error (char *fstr, ...);
  162. Object first_put (Object item, Object list);
  163. Object last_put (Object item, Object list);
  164. Object list (Object item, ...);
  165. Object append (Object list_1, Object list_2);
  166. Object reverse (Object list);
  167. Object flatten (Object obj);
  168. Object flatten_no_nils (Object obj);
  169. void for_each (Function_1 f, Object list);
  170. Object map (Function_1 f, Object list);
  171. Object map_no_nils (Function_1 f, Object list);
  172. Object nth (Object list, int n);
  173. Object assoc (Object key, Object a_list);
  174. Object pop_f (Object *location);
  175. int length (Object list);
  176. Object is_member (Object obj, Object list);
  177. int index (Object element, Object list);
  178. char *make_c_string (char *str);
  179. Object make_symbol (char *name);
  180. Object make_string (char *s);
  181. Object make_integer (int n);
  182. Object make_function (Function f);
  183. Object make_token (Object type, char *lexeme);
  184. Object make_vector (int length);
  185. Object list_to_vector (Object list);
  186. void write_object (Object obj);
  187. Object read_object (void);
  188. Object lookup (char *str);
  189. Object intern (char *str);
  190. Object install_with_value (char *str, Object val);
  191. Object set_symbol_value (Object sym, Object val);
  192. void install_internal_symbols (void);
  193. void mark (void);
  194. void free_to_mark (void);
  195. void mark_persistent (void);
  196. void unmark_persistent (void);
  197. Pointer safe_malloc (size_t size);
  198. void safe_free (void *p);
  199. void free_object (Object obj);
  200. Object copy_object (Object obj);
  201. Object persistent_copy_object (Object obj);
  202. void init_internal_read_table (void);
  203. void set_internal_reader (void);
  204.  
  205.  
  206. [LISTING TWO]
  207.  
  208. /* File I-SYMS.H of 28-Jan-91 / Copyright (C) 1990 by Daniel N. Ozick */
  209.  
  210. /** Declaration of Symbols in Internal Symbol Table **/
  211. /* Symbol Types */
  212. declare_symbol (SYMBOL_TYPE,    SYMBOL_TYPE);
  213. declare_symbol (RESERVED,       SYMBOL_TYPE);
  214. declare_symbol (CHAR_TYPE,      SYMBOL_TYPE);
  215. declare_symbol (TOKEN_TYPE,     SYMBOL_TYPE);
  216. /* Reserved "Lisp" Symbols */
  217. declare_symbol (_UNDEFINED,     RESERVED);
  218. declare_symbol (NIL,            RESERVED);
  219. declare_symbol (T,              RESERVED);
  220. declare_symbol (EOF_OBJECT,     RESERVED);
  221. /* Character Types */
  222. declare_symbol (ILLEGAL,        CHAR_TYPE);
  223. declare_symbol (WHITESPACE,     CHAR_TYPE);
  224. declare_symbol (STRING_MARKER,  CHAR_TYPE);
  225. declare_symbol (COMMENT_MARKER, CHAR_TYPE);
  226. declare_symbol (SPECIAL,        CHAR_TYPE);
  227. declare_symbol (CONSTITUENT,    CHAR_TYPE);
  228. declare_symbol (ESCAPE_MARKER,  CHAR_TYPE);
  229. declare_symbol (ENDFILE_MARKER, CHAR_TYPE);
  230. /** Token Types **/
  231. /* For Internal Diagnostics */
  232. declare_symbol (T_ERROR,        TOKEN_TYPE);
  233. /* Internal Special Symbols (Lisp IO) */
  234. declare_symbol (T_LPAREN,       TOKEN_TYPE);
  235. declare_symbol (T_RPAREN,       TOKEN_TYPE);
  236. /* Others */
  237. declare_symbol (T_NEWLINE,      TOKEN_TYPE);
  238. declare_symbol (T_WHITESPACE,   TOKEN_TYPE);
  239. declare_symbol (T_WORD,         TOKEN_TYPE);
  240. declare_symbol (T_STRING,       TOKEN_TYPE);
  241. declare_symbol (T_EOF,          TOKEN_TYPE);
  242.  
  243.  
  244.  
  245. [LISTING THREE]
  246.  
  247. /* File LISP.C of 6-Feb-91 / Copyright (C) 1990 by Daniel N. Ozick */
  248.  
  249. /** Lisp-Style Library for C (Main File of User Functions) **/
  250. /* Include Files */
  251. #include <stdlib.h>
  252. #include <string.h>
  253. #include <stdio.h>
  254. #include <stdarg.h>
  255. #include "lisp.h"
  256. #include "i-syms.h"
  257. /** Functions **/
  258. /* error -- write string (args like 'printf') to 'stdout' and exit */
  259. void error (char *fstr, ...)
  260.  {
  261.   va_list ap;
  262.   va_start (ap, fstr);
  263.   vfprintf (stdout, fstr, ap);
  264.   fputc (NEWLINE, stdout);
  265.   /* write DOS_EOF to 'stdout' for compatibility */
  266.   fputc (DOS_EOF, stdout);
  267.   exit (1);
  268.   va_end (ap);
  269.  }
  270. /** List Constructors **/
  271. /* first_put -- add an Object to the front of a list (Lisp CONS) */
  272. Object first_put (Object item, Object list)
  273.  {
  274.   Object new_list;
  275.   new_list = (Object) safe_malloc (sizeof (Object_Type) + sizeof (Pair));
  276.   type (new_list) = PAIR;
  277.   pair (new_list) -> car = item;
  278.   pair (new_list) -> cdr = list;
  279.   return (new_list);
  280.  }
  281. /* last_put -- add an Object to the end of a list (Destructive!) */
  282. Object last_put (Object item, Object list)
  283.  {
  284.   Object old_list, new_list;
  285.   new_list = first_put (item, NULL);
  286.   if (list == NULL)
  287.    return (new_list);
  288.   else
  289.    {
  290.     old_list = list;
  291.     while (but_first (list) != NULL)
  292.      list = but_first (list);
  293.     pair (list) -> cdr = new_list;
  294.     return (old_list);
  295.    }
  296.  }
  297. /* list -- return a new list of given arguments (last arg must be NULL) */
  298. Object list (Object item, ...)
  299.  {
  300.   va_list ap;
  301.   Object result;
  302.   result = NULL;
  303.   va_start (ap, item);
  304.   while (item != NULL)
  305.    {
  306.     result = last_put (item, result);
  307.     item = va_arg (ap, Object);
  308.    }
  309.   va_end (ap);
  310.   return (result);
  311.  }
  312. /* append -- concatenate two lists (destructive (!) Lisp equivalent) */
  313. Object append (Object list_1, Object list_2)
  314.  {
  315.   Object list;
  316.   if (list_1 == NULL)
  317.    return (list_2);
  318.   else
  319.   if (list_2 == NULL)
  320.    return (list_1);
  321.   else
  322.    {
  323.     list = list_1;
  324.     while (but_first (list) != NULL)
  325.      list = but_first (list);
  326.     pair (list) -> cdr = list_2;
  327.     return (list_1);
  328.    }
  329.  }
  330. /** List Modifiers **/
  331. /* reverse -- return a new list in reverse order (Lisp equivalent) */
  332. Object reverse (Object list)
  333.  {
  334.   Object new_list;
  335.   new_list = NULL;
  336.   while (list != NULL)
  337.    {
  338.     new_list = first_put (first (list), new_list);
  339.     list = but_first (list);
  340.    }
  341.   return (new_list);
  342.  }
  343. /* flatten -- return the leaves of a tree (atoms of nested lists) */
  344. Object flatten (Object obj)
  345.  {
  346.   if (is_null (obj))
  347.    return (first_put (NULL, NULL));
  348.   else if (is_atom (obj))
  349.    return (list (obj, NULL));
  350.   else if (is_null (but_first (obj)))
  351.    return (flatten (first (obj)));
  352.   else
  353.    return (append (flatten (first (obj)),
  354.                    flatten (but_first (obj)) ));
  355.  }
  356. /* flatten_no_nils -- 'flatten' a tree, discarding NULL atoms */
  357. Object flatten_no_nils (Object obj)
  358.  {
  359.   if (is_null (obj))
  360.    return (NULL);
  361.   else if (is_atom (obj))
  362.    return (list (obj, NULL));
  363.   else
  364.    return (append (flatten_no_nils (first (obj)), 
  365.                                   flatten_no_nils (but_first (obj)) ));
  366.  }
  367. /** Mapping Functions **/
  368. /* for_each -- apply a function 'f' to each element of a list */
  369. void for_each (Function_1 f, Object list)
  370.  {
  371.   while (list != NULL)
  372.    {
  373.     (*f) (first (list));
  374.     list = but_first (list);
  375.    }
  376.  }
  377. /* map -- apply a function 'f' to each element of list, put results in list */
  378. Object map (Function_1 f, Object list)
  379.  {
  380.   Object output;
  381.   output = NULL;
  382.   while (list != NULL)
  383.    {
  384.     output = first_put ((*f) (first (list)), output);
  385.     list = but_first (list);
  386.    }
  387.   return (reverse (output));
  388.  }
  389. /* map_no_nils -- like 'map', but collect only non-NULL results */
  390. Object map_no_nils (Function_1 f, Object list)
  391.  {
  392.   Object result;
  393.   Object output;
  394.   output = NULL;
  395.   while (list != NULL)
  396.    {
  397.     result = (*f) (first (list));
  398.     if (result != NULL)
  399.      output = first_put (result, output);
  400.     list = but_first (list);
  401.    }
  402.   return (reverse (output));
  403.  }
  404. /** List Selectors **/
  405. /* nth -- return nth element of a list or NULL (Lisp equivalent) */
  406. Object nth (Object list, int n)
  407.  {
  408.   while ((list != NULL) && (n > 0))
  409.    {
  410.     list = but_first (list);
  411.     n--;
  412.    }
  413.   if (list != NULL)
  414.    return (first (list));
  415.   else
  416.    return (NULL);
  417.  }
  418. /* assoc -- association-list lookup returns PAIR whose 'first' matches key */
  419. Object assoc (Object key, Object a_list)
  420.  {
  421.   Object pair;
  422.   while (a_list != NULL)
  423.    {
  424.     pair = first (a_list);
  425.     if (first (pair) == key)
  426.      return (pair);
  427.     else
  428.      a_list = but_first (a_list);
  429.    }
  430.   return (NULL);
  431.  }
  432. /* pop_f -- pop an object off of a (list-based) stack: 'pop' macro helper */
  433. Object pop_f (Object *location)
  434.  {
  435.   Object item;
  436.   item = first (*location);
  437.   *location = but_first (*location);
  438.   return (item);
  439.  }
  440.  
  441. /* List Properties */
  442. /* length -- return the integer length of a list (Lisp equivalent) */
  443. int length (Object list)
  444.  {
  445.   int n;
  446.   n = 0;
  447.   while (list != NULL)
  448.    {
  449.     list = but_first (list);
  450.     n++;
  451.    }
  452.   return (n);
  453.  }
  454. /* is_member -- T if 'obj' is identical to element of 'list', else NULL */
  455. Object is_member (Object obj, Object list)
  456.  {
  457.   while (list != NULL)
  458.    {
  459.     if (first (list) == obj)
  460.      return (T);
  461.     else
  462.      list = but_first (list);
  463.    }
  464.   return (NULL);
  465.  }
  466. /* index -- return index of first occurence of 'element' in 'list' */
  467. int index (Object element, Object list)
  468.  {
  469.   int n;
  470.   n = 0;
  471.   while ((list != NULL) &&
  472.          (first (list) != element) )
  473.    {
  474.     list = but_first (list);
  475.     n++;
  476.    }
  477.   if (list != NULL)
  478.    return (n);
  479.   else
  480.    return (-1);
  481.  }
  482. /** Object Constructors **/
  483. /* make_c_string -- make new copy of argument string in free memory */
  484. char *make_c_string (char *str)
  485.  {
  486.   char *new_string;
  487.   new_string = (char *) safe_malloc (strlen (str) + 1);
  488.   strcpy (new_string, str);
  489.   return (new_string);
  490.  }
  491. /* make_symbol -- return a new symbol of given name (no table lookup) */
  492. Object make_symbol (char *name)
  493.  {
  494.   Object new_symbol;
  495.   new_symbol = (Object) safe_malloc (sizeof (Object_Type) +
  496.                                                     sizeof (Symbol_Entry) );
  497.   type (new_symbol) = SYMBOL;
  498.   symbol (new_symbol) -> print_name = make_c_string (name);
  499.   symbol (new_symbol) -> value = _UNDEFINED;
  500.   return (new_symbol);
  501.  }
  502. /* make_string -- return a new STRING Object with value of given string */
  503. Object make_string (char *s)
  504.  {
  505.   Object new_string;
  506.   new_string = (Object) safe_malloc (sizeof (Object_Type) + strlen (s) + 1 );
  507.   type (new_string) = STRING;
  508.   strcpy (string (new_string), s);
  509.   return (new_string);
  510.  }
  511. /* make_integer -- return a new INTEGER Object of specfied value */
  512. Object make_integer (int n)
  513.  {
  514.   Object new_integer;
  515.   new_integer = (Object) safe_malloc (sizeof (Object_Type) + sizeof (int) );
  516.   type (new_integer) = INTEGER;
  517.   integer (new_integer) = n;
  518.   return (new_integer);
  519.  }
  520. /* make_function -- return a new FUNCTION Object of specfied value */
  521. Object make_function (Function f)
  522.  {
  523.   Object new_function;
  524.   new_function = (Object) safe_malloc (sizeof (Object_Type) +
  525.                                                           sizeof (Function) );
  526.   type (new_function) = FUNCTION;
  527.   function (new_function) = f;
  528.   return (new_function);
  529.  }
  530. /* make_token -- return a new TOKEN Object of specified type and lexeme */
  531. Object make_token (Object type, char *lexeme)
  532.  {
  533.   Object new_token;
  534.   new_token = (Object) safe_malloc (sizeof (Object_Type) + sizeof (Token));
  535.   type (new_token) = TOKEN;
  536.   token (new_token) -> type = type;
  537.   token (new_token) -> lexeme = make_c_string (lexeme);
  538.   return (new_token);
  539.  }
  540. /** Vectors **/
  541. /* make_vector -- return a new VECTOR object of specified 'length' */
  542. Object make_vector (int length)
  543.  {
  544.   Object new_vector;
  545.   int i;
  546.   new_vector = (Object) safe_malloc (sizeof (Object_Type) + sizeof (int) +
  547.                                                    length * sizeof (Object) );
  548.   type (new_vector) = VECTOR;
  549.   vector_length (new_vector) = length;
  550.   for (i = 0; i < length; i++)
  551.    vector(new_vector) [i] = NULL;
  552.   return (new_vector);
  553.  }
  554. /* list_to_vector -- given a (proper) list, return a new VECTOR Object */
  555. Object list_to_vector (Object list)
  556.  {
  557.   Object new_vector;
  558.   Object *element;
  559.   new_vector = make_vector (length (list));
  560.   element = vector(new_vector);
  561.   while (list != NULL)
  562.    {
  563.     *element = first (list);
  564.     list = but_first (list);
  565.     element++;
  566.    }
  567.   return (new_vector);
  568.  }
  569. /** Symbolic Output **/
  570. /* write_spaces -- write 'n' spaces to 'stdout' */
  571. void write_spaces (int n)
  572.  {
  573.   int i;
  574.   for (i = 0; i < n; i++)
  575.    putchar (SPACE);
  576.  }
  577. /* write_c_string -- write standard C string with double-quotes and escapes */
  578. void write_c_string (char *s)
  579.  {
  580.   putchar (DOUBLE_QUOTE);
  581.   while (*s != EOS)
  582.    {
  583.     switch (*s)
  584.      {
  585.       case NEWLINE:
  586.        putchar (BACKSLASH);
  587.        putchar ('n');
  588.        break;
  589.       case TAB:
  590.        putchar (BACKSLASH);
  591.        putchar ('t');
  592.        break;
  593.       case FORMFEED:
  594.        putchar (BACKSLASH);
  595.        putchar ('f');
  596.        break;
  597.       case BACKSLASH:
  598.        putchar (BACKSLASH);
  599.        putchar (BACKSLASH);
  600.        break;
  601.       case DOUBLE_QUOTE:
  602.        putchar (BACKSLASH);
  603.        putchar (DOUBLE_QUOTE);
  604.        break;
  605.       default:
  606.        putchar (*s);
  607.        break;
  608.      }
  609.     s++;
  610.    }
  611.   putchar (DOUBLE_QUOTE);
  612.  }
  613. /* write_symbol -- write printed representation of SYMBOL Object */
  614. void write_symbol (Object obj)
  615.  {
  616.   printf ("%s", symbol(obj)->print_name);
  617.  }
  618. /* write_string -- write printed representation of STRING Object */
  619. void write_string (Object obj)
  620.  {
  621.   write_c_string (string(obj));
  622.  }
  623. /* pp_object -- pretty-print an Object starting at 'col', output at 'hpos' */
  624. void pp_object (Object obj, int col, int hpos)
  625.  {
  626.   int i;
  627.   write_spaces (col - hpos);   hpos = col;
  628.   if (obj == NULL)
  629.    printf ("()");
  630.   else
  631.    switch (type(obj))
  632.     {
  633.      case SYMBOL:
  634.       write_symbol (obj);
  635.       break;
  636.      case STRING:
  637.       write_string (obj);
  638.       break;
  639.      case INTEGER:
  640.       printf ("%d", integer(obj));
  641.       break;
  642.      case PAIR:
  643.       /* for now, assume proper list (ending in NULL 'but_first') */
  644.       putchar (LEFT_PAREN);   hpos++;
  645.       while (obj != NULL)
  646.        {
  647.         if (! is_pair (obj))
  648.          error ("pp_object: not proper list");
  649.         pp_object (first (obj), col+1, hpos);
  650.         obj = but_first (obj);
  651.         if (obj != NULL)
  652.          {
  653.           putchar (NEWLINE);   hpos = 0;
  654.          }
  655.        }
  656.       putchar (RIGHT_PAREN);
  657.       break;
  658.      case VECTOR:
  659.       putchar ('#');          hpos++;
  660.       putchar (LEFT_PAREN);   hpos++;
  661.       for (i = 0; i < vector_length(obj); i++)
  662.        {
  663.         pp_object (vector(obj) [i], col+2, hpos);
  664.         if (i < vector_length(obj)-1)
  665.          {
  666.           putchar (NEWLINE); hpos = 0;
  667.          }
  668.        }
  669.       putchar (RIGHT_PAREN);
  670.       break;
  671.      case FUNCTION:
  672.       printf ("#<function>");
  673.       break;
  674.      case TOKEN:
  675.       printf ("#S(TOKEN ");
  676.       write_symbol (token(obj)->type);
  677.       putchar (SPACE);
  678.       write_c_string (token(obj)->lexeme);
  679.       putchar (RIGHT_PAREN);
  680.       break;
  681.      default:
  682.       error ("pp_object: not standard object");
  683.       break;
  684.     }
  685.  }
  686. /* write_object -- write (re-readable) printed representation of Object */
  687. void write_object (Object obj)
  688.  {
  689.   /* for now (simple version), assume 'hpos' initially 0 */
  690.   pp_object (obj, 0, 0);
  691.  }
  692.  
  693.  
  694.  
  695. [LISTING FOUR]
  696.  
  697. /* File SYMBOLS.C of 5-Feb-91 / Copyright (C) 1990 by Daniel N. Ozick */
  698.  
  699. /** Symbol Tables and Installed Symbols **/
  700. /* Include Files */
  701. #include <stdio.h>
  702. #include <string.h>
  703. #include "lisp.h"
  704. /** Variables **/
  705. /* internal_symbols -- the symbol table for "Lisp" */
  706. Hash_Table internal_symbols;
  707. /* symbol_table -- pointer to the current symbol table */
  708. Object *symbol_table;
  709. /* Predefined Internal Symbols */
  710. #undef declare_symbol
  711. #define declare_symbol(name,type)   \
  712.   Object name
  713. #include "i-syms.h"
  714. /** Functions **/
  715. /* init_hash_table -- set all hash buckets in a table to the empty list */
  716. void init_hash_table (Hash_Table table)
  717.  {
  718.   int i;
  719.   for (i = 0; i < HASH_TABLE_SZ; i++)
  720.    table [i] = NULL;
  721.  }
  722. /* hash -- given a character string, return a hash code (from Aho, p. 436) */
  723. int hash (char *str)
  724.  {
  725.   char *p;
  726.   unsigned long g, h;
  727.   /* from the book "Compilers" by Aho, Sethi, and Ullman, p. 436 */
  728.   h = 0;
  729.   for (p = str; *p != EOS; p++)
  730.    {
  731.     h = (h << 4) + (*p);
  732.     g = h & 0xF0000000;
  733.     if (g)
  734.      {
  735.       h = h ^ (g >> 24);
  736.       h = h ^ g;
  737.      }
  738.    }
  739.   return ( (int) (h % HASH_TABLE_SZ));
  740.  }
  741. /* lookup -- given a string, return symbol from 'symbol_table' or NULL */
  742. Object lookup (char *str)
  743.  {
  744.   Object hash_bucket;           /* list   */
  745.   Object sym;                   /* symbol */
  746.   hash_bucket = symbol_table [hash (str)];
  747.   /* walk linearly down 'hash_bucket' list looking for input string */
  748.   while (hash_bucket != NULL)
  749.    {
  750.     sym = first (hash_bucket);
  751.     if (strcmp (symbol (sym) -> print_name, str) == 0)
  752.      return (sym);
  753.     else
  754.      hash_bucket = but_first (hash_bucket);
  755.    }
  756.   return (NULL);
  757.  }
  758. /* install -- add a new symbol with given print string to 'symbol_table' */
  759. Object install (char *str)
  760.  {
  761.   Object new_sym;
  762.   int hash_index;
  763.   new_sym = make_symbol (str);
  764.   /* insert new symbol object at the front of appropriate hash bucket list */
  765.   hash_index = hash (str);
  766.   symbol_table [hash_index] = first_put (new_sym, symbol_table [hash_index]);
  767.   return (new_sym);
  768.  }
  769. /* intern -- return (possibly new and just installed) symbol of given name */
  770. Object intern (char *str)
  771.  {
  772.   Object sym;           /* symbol */
  773.   sym = lookup (str);
  774.   if (sym == NULL)
  775.    sym = install (str);
  776.   return (sym);
  777.  }
  778. /* set_symbol_value -- set the value of an already installed symbol */
  779. Object set_symbol_value (Object sym, Object val)
  780.  {
  781.   symbol (sym) -> value = val;
  782.   return (val);
  783.  }  
  784. /* install_with_value -- add a new symbol and its value to 'symbol_table' */
  785. Object install_with_value (char *str, Object val)
  786.  {
  787.   Object new_sym;
  788.   new_sym = install (str);
  789.   set_symbol_value (new_sym, val);
  790.   return (new_sym);
  791.  }
  792. /* install_internal_symbols -- set internal symbols known at compile time */
  793. void install_internal_symbols (void)
  794.  {
  795.   symbol_table = internal_symbols;
  796.   #undef declare_symbol
  797.   #define declare_symbol(name,type)   \
  798.     name = install_with_value (#name, type)
  799.   #include "i-syms.h"
  800.   install_with_value ("(", T_LPAREN);
  801.   install_with_value (")", T_RPAREN);
  802.  }
  803.  
  804.  
  805.  
  806. [LISTING FIVE]
  807.  
  808. /* File LEXER.C of 6-Feb-91 / Copyright (C) 1990 by Daniel N. Ozick */
  809.  
  810. /** Lexical Analyzer (a.k.a. Lexer, Scanner, or Reader) **/
  811. /* Include Files */
  812. #include <stdio.h>
  813. #include <stdlib.h>
  814. #include <ctype.h>
  815. #include <string.h>
  816. #include "lisp.h"
  817. #include "i-syms.h"
  818. /* External Variables */
  819. extern Object *symbol_table;
  820. extern Hash_Table internal_symbols;
  821. /* Internal Function Prototypes */
  822. Object read_list (Object first_atom);
  823. /* Constants */
  824. #define CHAR_SET_SZ 256
  825. /** Types **/
  826. /* Read_Table -- array giving CHAR_TYPE SYMBOL for every char and EOF */
  827. typedef Object Read_Table [CHAR_SET_SZ+1];
  828. /** Variables **/
  829. /* internal_read_table -- read table for "Lisp" reader */
  830. Read_Table internal_read_table;
  831. /* read_table -- pointer to the current read table */
  832. Object *read_table;
  833. /* eof_seen -- 'get_token' (EOF) sets TRUE */
  834. Boolean eof_seen = FALSE;
  835. /** Macros **/
  836. /* char_type -- return char type of char or EOF from current read table */
  837. #define char_type(c)    read_table[c+1]
  838. /** Functions **/
  839. /* set_read_table_entries -- set a list of read-table entries to Char_Type */
  840. void set_read_table_entries (char *s, Object t)
  841.  {
  842.   while (*s != EOS)
  843.    char_type (*s++) = t;
  844.  }
  845. /* init_read_table -- initialize 'read_table' with CONSTITUENT and EOF */
  846. void init_read_table (void)
  847.  {
  848.   int c;
  849.   for (c = 0; c < CHAR_SET_SZ; c++)
  850.    char_type (c) = CONSTITUENT;
  851.   char_type (EOF) = ENDFILE_MARKER;
  852.  }
  853. /* init_internal_read_table -- initialize 'internal_read_table' */
  854. void init_internal_read_table (void)
  855.  {
  856.   read_table = internal_read_table;
  857.   init_read_table ();
  858.   set_read_table_entries (" \t\f\n", WHITESPACE);
  859.   set_read_table_entries (";", COMMENT_MARKER);
  860.   set_read_table_entries ("()", SPECIAL);
  861.   char_type (DOUBLE_QUOTE) = STRING_MARKER;
  862.   char_type (BACKSLASH) = ESCAPE_MARKER;
  863.  }
  864. /* set_internal_reader -- set 'read_table' and 'symbol_table' for Lisp I/O */
  865. void set_internal_reader (void)
  866.  {
  867.   read_table = internal_read_table;
  868.   symbol_table = internal_symbols;
  869.  }
  870. /* get_whitespace -- return TOKEN Object of type T_WHITESPACE */
  871. Object get_whitespace (void)
  872.  {
  873.   char lexeme [MAXSTRING];
  874.   int index;
  875.   int current_char;
  876.   /* collect characters up to next non-whitespace */
  877.   index = 0;
  878.   while (current_char = getchar (),
  879.          (char_type (current_char) == WHITESPACE) &&
  880.          (index < MAXSTRING-1) )
  881.    lexeme [index++] = (char) current_char;
  882.   lexeme [index] = EOS;
  883.   ungetchar (current_char);
  884.   return (make_token (T_WHITESPACE, lexeme));
  885.  }
  886. /* get_escaped_char -- return single character value, line splice ==> EOS */
  887. int get_escaped_char (void)
  888.  {
  889.   int c;
  890.   /* discard ESCAPE_MARKER */
  891.   getchar ();
  892.   switch (c = getchar ())
  893.    {
  894.     case 'n':
  895.      return (NEWLINE);
  896.      break;
  897.     case 't':
  898.      return (TAB);
  899.      break;
  900.     case 'f':
  901.      return (FORMFEED);
  902.      break;
  903.     case BACKSLASH:
  904.      return (BACKSLASH);
  905.      break;
  906.     case DOUBLE_QUOTE:
  907.      return (DOUBLE_QUOTE);
  908.      break;
  909.     /* Note: LINE_SPLICE should really be discarded */
  910.     case NEWLINE:
  911.      return (LINE_SPLICE);
  912.      break;
  913.     default:
  914.      return (c);
  915.      break;
  916.    }
  917.  }
  918. /* get_string -- return TOKEN Object of type T_STRING */
  919. Object get_string (void)
  920.  {
  921.   char lexeme [MAXSTRING];
  922.   int index;
  923.   int current_char;
  924.   /* discard starting STRING_MARKER */
  925.   getchar ();
  926.   /* collect characters until next (unescaped) STRING_MARKER */
  927.   index = 0;
  928.   while (current_char = getchar (),
  929.          (char_type (current_char) != STRING_MARKER) &&
  930.          (index < MAXSTRING-1) )
  931.    {
  932.     if (char_type (current_char) != ESCAPE_MARKER)
  933.      lexeme [index++] = (char) current_char;
  934.     else
  935.      {
  936.       ungetchar (current_char);
  937.       lexeme [index++] = (char) get_escaped_char ();
  938.      }
  939.    }
  940.   lexeme [index] = EOS;
  941.   return (make_token (T_STRING, lexeme));
  942.  }
  943. /* skip_comment -- discard characters of a 'get_token' (line) comment */
  944. void skip_comment (void)
  945.  {
  946.   while (getchar () != NEWLINE)
  947.    ;
  948.  }
  949. /* get_special_sym -- return one of the special-symbol TOKEN Objects */
  950. Object get_special_sym (void)
  951.  {
  952.   int current_char;
  953.   char lexeme [3];
  954.   Object sym;
  955.   current_char = getchar ();
  956.   lexeme [0] = (char) current_char;
  957.   /* check for two-character special symbol */
  958.   current_char = getchar ();
  959.   lexeme [1] = (char) current_char;
  960.   lexeme [2] = EOS;
  961.   sym = lookup (lexeme);
  962.   if (sym != NULL)
  963.    return (make_token (symbol_value (sym), lexeme));
  964.   /* check for one-character special symbol */
  965.   else
  966.    {
  967.     ungetchar (current_char);
  968.     lexeme [1] = EOS;
  969.     sym = lookup (lexeme);
  970.     if (sym != NULL)
  971.      return (make_token (symbol_value (sym), lexeme));
  972.     /* else error */
  973.     else
  974.      error ("get_special_sym: no token type for '%s' ", lexeme);
  975.    }
  976.  }
  977. /* get_word -- return TOKEN Object of type T_WORD */
  978. Object get_word (void)
  979.  {
  980.   char lexeme [MAXSTRING];
  981.   int index;
  982.   int current_char;
  983.   /* collect characters up to next non-constituent */
  984.   index = 0;
  985.   while (current_char = getchar (),
  986.          (char_type (current_char) == CONSTITUENT) &&
  987.          (index < MAXSTRING-1) )
  988.    lexeme [index++] = (char) current_char;
  989.   lexeme [index] = EOS;
  990.   ungetchar (current_char);
  991.   return (make_token (T_WORD, lexeme));
  992.  }
  993. /* get_token -- return a single TOKEN Object (raw version) */
  994. Object get_token (void)
  995.  {
  996.   int current_char;
  997.   Object ct;
  998.   if (eof_seen)
  999.    error ("get_token: attempt to read past end of file");
  1000.   current_char = peekchar ();
  1001.   ct = char_type (current_char);
  1002.   if (ct == CONSTITUENT)
  1003.    return (get_word ());
  1004.   else if (ct == WHITESPACE)
  1005.    return (get_whitespace ());
  1006.   else if (ct == SPECIAL)
  1007.    return (get_special_sym ());
  1008.   else if (ct == STRING_MARKER)
  1009.    return (get_string ());
  1010.   else if (ct == COMMENT_MARKER)
  1011.    {
  1012.     skip_comment ();
  1013.     return (get_token ());
  1014.    }
  1015.   else if (ct == ESCAPE_MARKER)
  1016.    {
  1017.     /* discard anything but LINE_SPLICE */
  1018.     if (get_escaped_char () == LINE_SPLICE)
  1019.      return (make_token (T_WHITESPACE, NEWLINESTR));
  1020.     else
  1021.      return (get_token ());
  1022.    }
  1023.   else if (ct == ENDFILE_MARKER)
  1024.    {
  1025.     /* set end-of-file flag (see 'with_current_files') */
  1026.     eof_seen = TRUE;
  1027.     return (make_token (T_EOF, NULLSTR));
  1028.    }
  1029.   else
  1030.    error ("get_token: bad char type for '%c' ", current_char);
  1031.  }     
  1032. /* symbol_or_number -- interpret string as SYMBOL or INTEGER Object */
  1033. Object symbol_or_number (char *s)
  1034.  {
  1035.   if (isdigit (*s))
  1036.    return (make_integer (atoi (s)));
  1037.   else
  1038.    return (intern (s));
  1039.  }
  1040. /* read_atom -- return an atomic Object or list-syntax TOKEN Object */
  1041. Object read_atom (void)
  1042.  {
  1043.   Object t, tt;
  1044.   t = get_token ();
  1045.   tt = token(t)->type;
  1046.   if (tt == T_WHITESPACE)
  1047.    return (read_atom ());
  1048.   else
  1049.   if (tt == T_WORD)
  1050.    return (symbol_or_number (token(t)->lexeme));
  1051.   else
  1052.   if (tt == T_STRING)
  1053.    return (make_string (token(t)->lexeme));
  1054.   else
  1055.   if (tt == T_EOF)
  1056.    return (EOF_OBJECT);
  1057.   else
  1058.   if ((tt == T_LPAREN) || (tt == T_RPAREN))
  1059.    return (t);
  1060.   else
  1061.    error ("read_atom: bad token type on input");
  1062.  }
  1063. /* read_object_1 -- 'read_object' with first input atom supplied */
  1064. Object read_object_1 (Object first_atom)
  1065.  {
  1066.   Object_Type ot;
  1067.   Object tt;
  1068.   ot = type(first_atom);
  1069.   if (ot == TOKEN)
  1070.    tt = token(first_atom)->type;
  1071.   if ((ot == TOKEN) && (tt == T_LPAREN))
  1072.    return (read_list (read_atom ()));
  1073.   else
  1074.   if ((ot == TOKEN) && (tt == T_RPAREN))
  1075.    error ("read_object_1: right paren without matching left paren");
  1076.   else
  1077.    return (first_atom);
  1078.  }
  1079. /* read_list -- read paren-delimited list (helper for 'read_object') */
  1080. Object read_list (Object first_atom)
  1081.  {
  1082.   Object_Type ot;
  1083.   Object tt;
  1084.   Object first, rest;
  1085.   ot = type(first_atom);
  1086.   if (ot == TOKEN)
  1087.    tt = token(first_atom)->type;
  1088.   if ((ot == TOKEN) && (tt == T_RPAREN))
  1089.    return (NULL);
  1090.   else
  1091.   if ((ot == TOKEN) && (tt == T_EOF))
  1092.    error ("read_list: EOF encountered before closing right paren");
  1093.   else
  1094.    {
  1095.     first = read_object_1 (first_atom);
  1096.     rest = read_list (read_atom ());
  1097.     return (first_put (first, rest));
  1098.    }
  1099.  }
  1100. /* read_object -- read complete Object, including paren-delimited list */
  1101. Object read_object (void)
  1102.  {
  1103.   return (read_object_1 (read_atom ()));
  1104.  }
  1105.  
  1106.  
  1107. [LISTING SIX]
  1108.  
  1109. /* File MEMORY.C of 6-Feb-91 / Copyright (C) 1990 by Daniel N. Ozick */
  1110.  
  1111. /** Memory Allocation and Deallocation Functions **/
  1112. /* Include Files */
  1113. #include <stdio.h>
  1114. #include <stdlib.h>
  1115. #include "lisp.h"
  1116. /* Constants */
  1117. #define MAX_MARK_LEVELS 16
  1118. /** Types **/
  1119. /* Mark_Type */
  1120. typedef enum
  1121.  {
  1122.   TEMPORARY,
  1123.   PERSISTENT
  1124.  } Mark_Type;
  1125. /* Mark -- an element of 'mark_stack' */
  1126. typedef struct
  1127.  {
  1128.   Mark_Type type;
  1129.   Pointer index;
  1130.  } Mark;
  1131. /** Variables **/
  1132. /* marked_block_list -- pointer to linked list of marked allocated blocks */
  1133. Pointer marked_block_list = NULL;
  1134. /* mark_stack -- stack of 'Mark' and stack index */
  1135. Mark mark_stack [MAX_MARK_LEVELS];
  1136. int mark_stack_index = 0;
  1137. /* alloc_persistent -- FALSE means stack pointers to freeable memory blocks */
  1138. Boolean alloc_persistent = TRUE;
  1139. /** Functions **/
  1140. /* push_marked_block -- push pointer to block on 'marked_block_list' */
  1141. void push_marked_block (Pointer p)
  1142.  {
  1143.   * (Pointer *) p = marked_block_list;
  1144.   marked_block_list = p;
  1145.  }
  1146. /* pop_marked_block -- pop pointer to block from 'marked_block_list' */
  1147. Pointer pop_marked_block (void)
  1148.  {
  1149.   Pointer p;
  1150.   p = marked_block_list;
  1151.   if (p != NULL)
  1152.    {
  1153.     marked_block_list = * (Pointer *) p;
  1154.     return (p);
  1155.    }
  1156.   else
  1157.    error ("pop_marked_block: 'marked_block_list' is empty");
  1158.  }
  1159. /* push_mark_stack -- push a Mark on top of 'mark_stack' */
  1160. void push_mark_stack (Mark m)
  1161.  {
  1162.   if (mark_stack_index < MAX_MARK_LEVELS)
  1163.    mark_stack [mark_stack_index++] = m;
  1164.   else
  1165.    error ("push_mark_stack: exceeded MAX_MARK_LEVELS");
  1166.  }
  1167. /* pop_mark_stack -- pop a Mark from 'mark_stack' */
  1168. Mark pop_mark_stack (void)
  1169.  {
  1170.   if (mark_stack_index > 0)
  1171.    return (mark_stack [--mark_stack_index]);
  1172.   else
  1173.    error ("pop_mark_stack: stack empty");
  1174.  }
  1175. /* top_mark_stack -- return top of 'mark_stack' or PERSISTENT Mark if empty */
  1176. Mark top_mark_stack (void)
  1177.  {
  1178.   Mark m;
  1179.   if (mark_stack_index > 0)
  1180.    return (mark_stack [mark_stack_index-1]);
  1181.   else
  1182.    {
  1183.     m.type = PERSISTENT;
  1184.     m.index = marked_block_list;
  1185.     return (m);
  1186.    }
  1187.  }
  1188. /* mark -- push TEMPORARY Mark (with 'marked_block_list') on 'mark_stack' */
  1189. void mark (void)
  1190.  {
  1191.   Mark m;
  1192.   m.type = TEMPORARY;
  1193.   m.index = marked_block_list;
  1194.   push_mark_stack (m);
  1195.   alloc_persistent = FALSE;
  1196.  }
  1197. /* free_to_mark -- 'safe_free' all memory blocks alloc'ed since last 'mark' */
  1198. void free_to_mark (void)
  1199.  {
  1200.   Mark m;
  1201.   m = pop_mark_stack ();
  1202.   if (m.type == TEMPORARY)
  1203.    {
  1204.     while (marked_block_list != m.index)
  1205.      safe_free ((char *) pop_marked_block () + sizeof (Pointer));
  1206.     alloc_persistent = (top_mark_stack().type == PERSISTENT);
  1207.    }
  1208.   else
  1209.    error ("free_to_mark: wrong mark type on 'mark_stack'");
  1210.  }
  1211. /* mark_persistent -- disable stacking of freeable memory block pointers */
  1212. void mark_persistent (void)
  1213.  {
  1214.   Mark m;
  1215.   m.type = PERSISTENT;
  1216.   m.index = marked_block_list;
  1217.   push_mark_stack (m);
  1218.   alloc_persistent = TRUE;
  1219.  }
  1220. /* unmark_persistent -- pop a PERSISTENT Mark off the 'mark_stack' */
  1221. void unmark_persistent (void)
  1222.  {
  1223.   Mark m;
  1224.   m = pop_mark_stack ();
  1225.   if (m.type == PERSISTENT)
  1226.    alloc_persistent = (top_mark_stack().type == PERSISTENT);
  1227.   else
  1228.    error ("unmark_persistent: wrong mark type on 'mark_stack'");
  1229.  }
  1230. /* safe_malloc -- Unix 'malloc' wrapped inside test for sufficient memory */
  1231. Pointer safe_malloc (size_t size)
  1232.  {
  1233.   Pointer memory;
  1234.   static long num_blocks = 0;
  1235.   static long total_space = 0;
  1236.   /* allocate block, including header for link in 'marked_block_list' */
  1237.   memory = malloc (size + sizeof (Pointer));
  1238.   num_blocks++;
  1239.   total_space += size;
  1240.   if (memory != NULL)
  1241.    {
  1242.     if (! alloc_persistent)
  1243.      push_marked_block (memory);
  1244.     /* return beginning of user data block */
  1245.     return ((char *) memory + sizeof (Pointer));
  1246.    }
  1247.   else
  1248.    error ("safe_malloc: out of memory"
  1249.           " (num_blocks = %ld, total_space = %ld) \n",
  1250.           num_blocks, total_space );
  1251.  }
  1252. /* safe_free -- Unix 'free' with first byte of block set to zero */
  1253. void safe_free (void *p)
  1254.  {
  1255.   * (char *) p = (char) 0;
  1256.   /* free block, including header for link in 'marked_block_list' */
  1257.   free ((char* ) p - sizeof (Pointer));
  1258.  }
  1259. /* free_object -- free memory for Object and recursively for its components */
  1260. void free_object (Object obj)
  1261.  {
  1262.   if (marked_block_list != NULL)
  1263.    error ("free_object: can't free if 'marked_block_list' not empty");
  1264.   if (obj == NULL)
  1265.    return;
  1266.   else
  1267.    switch (type(obj))
  1268.     {
  1269.      case SYMBOL:
  1270.       return;
  1271.       break;
  1272.      case STRING:
  1273.      case INTEGER:
  1274.      case FUNCTION:
  1275.       break;
  1276.      case PAIR:
  1277.       free_object (first(obj));
  1278.       free_object (but_first(obj));
  1279.       break;
  1280.      case VECTOR:
  1281.       error ("free_object: VECTOR objects not implemented yet");
  1282.       break;
  1283.      case TOKEN:
  1284.       safe_free (token(obj)->lexeme);
  1285.       break;
  1286.      default:
  1287.       error ("free_object: not standard object");
  1288.       break;
  1289.     }
  1290.   safe_free (obj);
  1291.  }
  1292. /* copy_object -- copy Object and its components recursively */
  1293. Object copy_object (Object obj)
  1294.  {
  1295.   if (obj == NULL)
  1296.    return (NULL);
  1297.   switch (type(obj))
  1298.    {
  1299.     case SYMBOL:
  1300.      return (obj);
  1301.     case STRING:
  1302.      return (make_string (string(obj)));
  1303.     case INTEGER:
  1304.      return (make_integer (integer(obj)));
  1305.     case FUNCTION:
  1306.      return (make_function (function(obj)));      
  1307.     case PAIR:
  1308.      return (first_put (copy_object (first(obj)), 
  1309.                                         copy_object (but_first(obj)) ));
  1310.     case VECTOR:
  1311.      error ("copy_object: VECTOR objects not implemented yet");
  1312.     case TOKEN:
  1313.      return (make_token (token(obj)->type, token(obj)->lexeme ));
  1314.     default:
  1315.      error ("copy_object: not standard object");
  1316.    }
  1317.  }
  1318. /* persistent_copy_object -- 'copy_object' wrapped in 'mark_persistent' */
  1319. Object persistent_copy_object (Object obj)
  1320.  {
  1321.   Object result;
  1322.   mark_persistent ();
  1323.   result = copy_object (obj);
  1324.   unmark_persistent ();
  1325.   return (result);
  1326.  }
  1327.  
  1328.  
  1329.  
  1330.  
  1331. [LISTING SEVEN]
  1332.  
  1333. /* File REPL.C of 11-Feb-91 / Copyright (C) 1991 by Daniel N. Ozick */
  1334. /* REPL: A Simplified Lisp-Style Read-Evaluate-Print Loop or 
  1335. A Tiny Lisp Interpreter
  1336. REPL is a simple interactive program intended to demonstrate some of the 
  1337. features of The Lisp-Style Library for C. At the DOS > prompt, it READs user 
  1338. input and attempts to convert that input into an internal Object. Then it 
  1339. EVALuates the input Object as a Lisp expression according to the rules below.  
  1340. Finally, it PRINTs the external representation of the result of evaluating the
  1341. input Object, and prompts for more input. This LOOP continues until either an 
  1342. error occurs or the user interrupts it with control-C or control-Break.
  1343. Lisp expressions are evaluated as follows: 1. The empty list evaluates to 
  1344. itself. 2. A symbol evaluates to its symbol_value. 3. Strings and integers 
  1345. evaluate to themselves. 4. A list whose first element is the symbol quote 
  1346. evaluates to the second element of the list. 5. A list whose first element is 
  1347. a symbol whose symbol_value is a  function evaluates to the result of applying 
  1348. that function to the  (recursively) evaluated elements of the rest of the list.
  1349. "Impure" Lisp-style functions--those that have non-Object inputs or output--
  1350. cannot be used in the Tiny Lisp Interpreter. These functions are for_each, map
  1351. (for which pmap is the equivalent "pure" version), map_no_nils, nth, length, 
  1352. and index. In addition, the interpreter cannot handle macros such as first, 
  1353. but_first, push, pop and the is_ type predicates. To create the REPL 
  1354. executable file, link the compiled versions of LISP.C, SYMBOLS.C, LEXER.C, 
  1355. MEMORY.C, and REPL.C. The required header files are LISP.H and I-SYMS.H. The 
  1356. Lisp-Style Library and this program have been compiled and tested using 
  1357. Microsoft C 6.0 under PC-DOS 3.3. */
  1358.  
  1359. /* Include Files */
  1360. #include <stdio.h>
  1361. #include "lisp.h"
  1362. /** Variables **/
  1363. /* quote -- marker SYMBOL for quoted-expression special form in 'eval' */
  1364. Object quote;
  1365. /** Macros **/
  1366. /* declare_function -- set up a SYMBOL whose value is FUNCTION (same name) */
  1367. #define declare_function(name)  \
  1368.   install_with_value (#name, make_function ((Function) name))
  1369. /** Functions **/
  1370. /* integers -- return the list of INTEGERs 'n1' through 'n2' inclusive */
  1371. Object integers (Object n1, Object n2)
  1372.  {
  1373.   int i;
  1374.   Object result;
  1375.   result = NULL;
  1376.   for (i = integer (n1); i <= integer (n2); i++)
  1377.    result = first_put (make_integer (i), result);
  1378.   return (reverse (result));
  1379.  }
  1380. /* sum -- return (as an INTEGER) the sum of a list of INTEGERs */
  1381. Object sum (Object list)
  1382.  {
  1383.   int sum;
  1384.   sum = 0;
  1385.   while (list != NULL)
  1386.    {
  1387.     sum += integer (first (list));
  1388.     list = but_first (list);
  1389.    }
  1390.   return (make_integer (sum));
  1391.  }    
  1392. /* square -- return (as an INTEGER) the square of an INTEGER */
  1393. Object square (Object n)
  1394.  {
  1395.   return (make_integer (integer (n) * integer (n)));
  1396.  }
  1397. /* The following function is the "purified" version of map. It has a non-Object
  1398. input and can't be used in the Tiny Lisp Interpreter. Similar purifications 
  1399. can be made for other impure functions in The Lisp-Style Library for C. */
  1400. /* pmap -- apply a function to each element of a list, put results in list */
  1401. Object pmap (Object f, Object list)
  1402.  {
  1403.   Object output;
  1404.   output = NULL;
  1405.   while (list != NULL)
  1406.    {
  1407.     output = first_put ((*function(f)) (first (list)), output);
  1408.     list = but_first (list);
  1409.    }
  1410.   return (reverse (output));
  1411.  }
  1412. /* install_function_symbols -- set up some symbols for read-eval-print loop */
  1413. void install_function_symbols (void)
  1414.  {
  1415.   /* pure Object functions from LISP.C */
  1416.   declare_function (first_put);
  1417.   declare_function (last_put);
  1418.   declare_function (reverse);
  1419.   declare_function (list);
  1420.   declare_function (append);
  1421.   declare_function (flatten);
  1422.   declare_function (flatten_no_nils);
  1423.   declare_function (is_member);
  1424.   declare_function (assoc);
  1425.   /* pure Object functions from REPL.C (examples for Tiny Interpreter) */
  1426.   declare_function (integers);
  1427.   declare_function (sum);
  1428.   declare_function (square);
  1429.   declare_function (pmap);
  1430.  }
  1431. /* apply -- apply a ("pure" Object) FUNCTION to a list of args (max of 8) */
  1432. Object apply (Object f, Object args)
  1433.  {
  1434.   return ((*function (f)) (nth (args, 0), nth (args, 1),
  1435.                            nth (args, 2), nth (args, 3),
  1436.                            nth (args, 4), nth (args, 5),
  1437.                            nth (args, 6), nth (args, 7) ));
  1438.  }
  1439. /* eval -- evaluate a Lisp-syntax expression (see notes above) */
  1440. Object eval (Object expr)
  1441.  {
  1442.   Object first_element, f;
  1443.   /* () is self-evaluating */
  1444.   if (is_null (expr))
  1445.    return (expr);
  1446.   /* symbol ==> symbol's value, other atoms are self-evaluating */
  1447.   else if (is_atom (expr))
  1448.    {
  1449.     if (is_symbol (expr))
  1450.      return (symbol_value (expr));
  1451.     else
  1452.      return (expr);
  1453.    }
  1454.   /* lists are function applications or quoted expressions */
  1455.   else if (is_pair (expr))
  1456.    {
  1457.     first_element = first (expr);
  1458.     if (first_element == quote)
  1459.      return (first (but_first (expr)));
  1460.     if (is_symbol (first_element))
  1461.      f = symbol_value (first_element);
  1462.     else
  1463.      error ("eval: first element of list is not a symbol");
  1464.     if (is_function (f))
  1465.      return (apply (f, map (eval, but_first (expr))));
  1466.     else
  1467.      error ("eval: symbol value is not a function");
  1468.    }
  1469.  }
  1470. /* main (REPL) -- interactive read-eval-print loop (Tiny Lisp Interpreter) */
  1471. int main (int argc, char *argv[])
  1472.  {
  1473.   printf ("A Tiny Lisp Interpreter using the Lisp-Style Library for C \n");
  1474.   printf ("Copyright (C) 1991 by Daniel N. Ozick \n\n");
  1475.   /* initialize internal symbol tables and read-tables */
  1476.   mark_persistent ();
  1477.   install_internal_symbols ();
  1478.   init_internal_read_table ();
  1479.   set_internal_reader ();
  1480.   install_function_symbols ();
  1481.   quote = intern ("quote");
  1482.   unmark_persistent ();
  1483.   /* do read-eval-print loop until user interrupt */
  1484.   while (TRUE)
  1485.    {
  1486.     mark ();
  1487.     printf ("\n> ");
  1488.     write_object (eval (read_object ()));
  1489.     free_to_mark ();
  1490.    }
  1491.   /* return "no errors" */
  1492.   return (0);
  1493.  }
  1494.